home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / rel-7-2-patches.lsp < prev    next >
Encoding:
Text File  |  1992-07-09  |  15.4 KB  |  388 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
  2.  
  3. ;=====================================
  4. (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
  5. (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
  6. (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  7.   "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
  8.  
  9. ;;; Does simple constant folding.  This works for everything that doesn't have
  10. ;;; side-effects.
  11. ;;; ALL operands must be constant.
  12. ;;; Note that commutative-constant-folder can hack this case perfectly well
  13. ;;; by himself for the functions he handles.
  14. (defun constant-fold-optimizer (form)
  15.   (let ((eval-when-load-p nil))
  16.     (flet ((constant-form-p (x)
  17.          (when (constant-form-p x)
  18.            (cond ((and (listp x)
  19.                (eq (car x) 'quote)
  20.                (listp (cadr x))
  21.                (eq (caadr x) eval-at-load-time-marker))
  22.               (setq eval-when-load-p t)
  23.               (cdadr x))
  24.              (t x)))))
  25.       (if (every (cdr form) #'constant-form-p)
  26.       (if eval-when-load-p
  27.           (list 'quote
  28.             (list* eval-at-load-time-marker
  29.                (car form)
  30.                (mapcar #'constant-form-p (cdr form))))
  31.           (condition-case (error-object)
  32.            (multiple-value-call #'(lambda (&rest values)
  33.                         (if (= (length values) 1)
  34.                         `',(first values)
  35.                         `(values ,@(mapcar #'(lambda (x) `',x)
  36.                                    values))))
  37.                     (eval form))
  38.          (error
  39.            (phase-1-warning "Constant form left unoptimized: ~S~%because: ~⑨~A~⑧"
  40.                     form error-object)
  41.            form)))
  42.       form))))
  43.  
  44.  
  45. ;=====================================
  46. (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
  47. (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
  48. (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  49.   "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
  50.  
  51. ;;;
  52. ;;; The damn compiler doesn't compile random forms that appear at top level.
  53. ;;; Its difficult to do because you have to get an associated function spec
  54. ;;; to go with those forms.  This handles that by defining a special form,
  55. ;;; top-level-form that compiles its body.  It takes a list of eval-when
  56. ;;; times just like eval when does.  It also takes a name which it uses
  57. ;;; to construct a function spec for the top-level-form function it has
  58. ;;; to create.
  59. ;;; 
  60. ;
  61. ;si::
  62. ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
  63. ;
  64. ;si::
  65. ;(define-function-spec-handler pcl::top-level-form
  66. ;                  (operation fspec &optional arg1 arg2)
  67. ;  (let ((name (cadr fspec)))
  68. ;    (selectq operation
  69. ;      (validate-function-spec (and (= (length fspec) 2)
  70. ;                   (or (symbolp name)
  71. ;                       (listp name))))
  72. ;      (fdefine
  73. ;       (setf (gethash name *top-level-form-fdefinitions*) arg1))
  74. ;      ((fdefinition fdefinedp)
  75. ;       (gethash name *top-level-form-fdefinitions*)) 
  76. ;      (fdefinition-location 
  77. ;       (ferror "It is not possible to get the fdefinition-location of ~s."
  78. ;           fspec))
  79. ;      (fundefine (remhash name *top-level-form-fdefinitions*))
  80. ;      (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
  81. ;
  82. ;;;
  83. ;;; This is basically stolen from PROGN (surprised?)
  84. ;;; 
  85. ;(si:define-special-form pcl::top-level-form (name times
  86. ;                          &body body
  87. ;                          &environment env)
  88. ;  (declare lt:(arg-template . body) (ignore name))
  89. ;  (si:check-eval-when-times times)
  90. ;  (when (member 'eval times) (si:eval-body body env)))
  91. ;
  92. ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
  93. ;  (lt::mapforms-list original-form form (cddr form) 'eval usage))
  94.  
  95. ;;; This is the normal function for looking at each form read from the file and calling
  96. ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
  97. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
  98. ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
  99. ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
  100. ;  (CATCH-ERROR-RESTART
  101. ;     (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
  102. ;    (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
  103. ;      (LET ((ERROR-MESSAGE-HOOK
  104. ;          #'(LAMBDA ()
  105. ;          (DECLARE (SYS:DOWNWARD-FUNCTION))
  106. ;          (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
  107. ;              DBG:*ERROR-MESSAGE-PRINLEVEL*
  108. ;              DBG:*ERROR-MESSAGE-PRINLENGTH*
  109. ;              FORM))))
  110. ;    (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
  111. ;      (WHEN (LISTP FORM)            ;Ignore atoms at top-level
  112. ;    (LET ((FUNCTION (FIRST FORM)))
  113. ;      (SELECTQ FUNCTION
  114. ;        ((QUOTE))                ;and quoted constants e.g. 'COMPILE
  115. ;        ((PROGN)
  116. ;         (DOLIST (FORM (CDR FORM))
  117. ;           (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
  118. ;        ((EVAL-WHEN)
  119. ;         (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
  120. ;         (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
  121. ;                  (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
  122. ;           (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
  123. ;           (FORMS (CDDR FORM)))
  124. ;           (COND (LOAD-P
  125. ;              (DOLIST (FORM FORMS)
  126. ;            (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
  127. ;             (COMPILE-P
  128. ;              (DOLIST (FORM FORMS)
  129. ;            (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
  130. ;        ((DEFUN)
  131. ;         (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
  132. ;           (IF (EQ (CDR TEM) (CDR FORM))
  133. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
  134. ;           (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
  135. ;        ((MACRO)
  136. ;         (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
  137. ;        ((DECLARE)
  138. ;         (DOLIST (FORM (CDR FORM))
  139. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
  140. ;            ;; (DECLARE (SPECIAL ... has load-time action as well.
  141. ;            ;; All other DECLARE's do not.
  142. ;            (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
  143. ;        ((COMPILER-LET)
  144. ;         (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
  145. ;                    #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
  146. ;        ((SI:DEFINE-SPECIAL-FORM)
  147. ;         (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
  148. ;        ((MULTIPLE-DEFINITION)
  149. ;         (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
  150. ;           (LET ((NAME-VALID (AND (NOT (NULL NAME))
  151. ;                      (OR (SYMBOLP NAME)
  152. ;                      (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
  153. ;             (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
  154. ;         (UNLESS (AND NAME-VALID TYPE-VALID)
  155. ;           (WARN "(~S ~S ~S ...) is invalid because~@
  156. ;              ~:[~S is not valid as a definition name~;~*~]~
  157. ;              ~:[~&~S is not valid as a definition type~;~*~]"
  158. ;             'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
  159. ;           (LET* ((COMPILED-BODY NIL)
  160. ;              (COMPILE-FUNCTION *COMPILE-FUNCTION*)
  161. ;              (*COMPILE-FUNCTION*
  162. ;            (LAMBDA (OPERATION &REST ARGS)
  163. ;              (DECLARE (SYS:DOWNWARD-FUNCTION))
  164. ;              (SELECTQ OPERATION
  165. ;                (:DUMP-FORM
  166. ;                 (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
  167. ;                        (FIRST ARGS))
  168. ;                   COMPILED-BODY))
  169. ;                (:INSTALL-DEFINITION
  170. ;                 (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
  171. ;                   COMPILED-BODY))
  172. ;                (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
  173. ;              (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
  174. ;                        ,@LOCAL-DECLARATIONS)))
  175. ;         (DOLIST (FORM BODY)
  176. ;           (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
  177. ;         (FUNCALL COMPILE-FUNCTION :DUMP-FORM
  178. ;              `(LOAD-MULTIPLE-DEFINITION
  179. ;                 ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
  180. ;        ((pcl::top-level-form)
  181. ;         (destructuring-bind (name times . body)
  182. ;                 (cdr form)
  183. ;           (si:check-eval-when-times times)
  184. ;           (let ((compile-p (or (memq 'compile times)
  185. ;                    (and compile-time-too (memq 'eval times))))
  186. ;             (load-p (or (memq 'load times)
  187. ;                 (memq 'cl:load times)))
  188. ;             (fspec `(pcl::top-level-form ,name)))
  189. ;         (cond (load-p
  190. ;            (compile-from-stream-1
  191. ;              `(progn (defun ,fspec () . ,body)
  192. ;                  (funcall (function ,fspec)))
  193. ;              (and compile-p ':force)))
  194. ;               (compile-p
  195. ;            (dolist (b body)
  196. ;              (funcall *compile-form-function* form ':force nil)))))))
  197. ;        (OTHERWISE
  198. ;         (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
  199. ;           (IF TEM
  200. ;           (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
  201. ;           (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
  202. ;
  203. ;
  204.  
  205.  
  206. dw::
  207. (defun symbol-flavor-or-cl-type (symbol)
  208.   (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
  209.            non-atomic-deftype))
  210.   (multiple-value-bind (result foundp)
  211.       (gethash symbol *flavor-or-cl-type-cache*)
  212.     (let ((frob
  213.         (if foundp result
  214.           (setf (gethash symbol *flavor-or-cl-type-cache*)
  215.             (or (get symbol 'flavor:flavor)
  216.             (not (null (defstruct-type-p symbol)))
  217.             (let* ((deftype (get symbol 'deftype))
  218.                    (descriptor (symbol-presentation-type-descriptor symbol))
  219.                    (typep
  220.                  (unless (and descriptor
  221.                           (presentation-type-explicit-type-function
  222.                         descriptor))
  223.                    ;; Don't override the one defined in the presentation-type.
  224.                    (get symbol 'typep)))
  225.                    (atomic-subtype-parent (find-atomic-subtype-parent symbol))
  226.                    (non-atomic-deftype
  227.                  (when (and (not descriptor) deftype)
  228.                    (not (member (first (type-arglist symbol))
  229.                         '(&rest &key &optional))))))
  230.               (if (or typep (not (atom deftype))
  231.                   non-atomic-deftype
  232.                   ;; deftype overrides atomic-subtype-parent.
  233.                   (and (not deftype) atomic-subtype-parent))
  234.                   (list-in-area *handler-dynamic-area*
  235.                         deftype typep atomic-subtype-parent
  236.                         non-atomic-deftype)
  237.                 deftype)))))))
  238.       (locally (declare (inline compiled-function-p))
  239.         (etypecase frob
  240.       (array (values frob))
  241.       (null (values nil))
  242.       ((member t) (values nil t))
  243.       (compiled-function (values nil nil frob))
  244.       (lexical-closure (values nil nil frob))
  245.       (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
  246.             frob
  247.           (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
  248.       (symbol (values nil nil nil nil frob)))))))
  249.  
  250. ;;;
  251. ;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser
  252. ;;;  is willing to look ahead while trying to parse a definition.  Even 2 lines is enough
  253. ;;;  for just about all cases, but there isn't much overhead, and 10 should be enough
  254. ;;;  to satisfy pretty much everyone... but feel free to change it.
  255. ;;;        - MT 880921
  256. ;;;
  257.  
  258. zwei:
  259. (defvar *sectionize-line-lookahead* 3)
  260.  
  261. zwei:
  262. (DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT)
  263.        (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS)
  264.   ADDED-COMPLETIONS ;ignored, obsolete
  265.   (WHEN STREAM
  266.     (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T))
  267.   (INCF *SECTIONIZE-BUFFER*)
  268.   (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*))
  269.     OLD-CHANGED-SECTIONS)
  270.     (TICK)
  271.     ;; Flush old section nodes.  Also collect the names of those that are modified, they are
  272.     ;; the ones that will be modified again after a revert buffer.
  273.     (DOLIST (NODE (NODE-INFERIORS BUFFER))
  274.       (AND (> (NODE-TICK NODE) BUFFER-TICK)
  275.        (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE)
  276.                (SECTION-NODE-DEFINITION-TYPE NODE))
  277.          OLD-CHANGED-SECTIONS))
  278.       (FLUSH-BP (INTERVAL-FIRST-BP NODE))
  279.       (FLUSH-BP (INTERVAL-LAST-BP NODE)))
  280.     (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE))
  281.      (LIMIT (BP-LINE LAST-BP))
  282.      (EOFFLG)
  283.      (ABNORMAL T)
  284.      (DEFINITION-LIST NIL)
  285.      (BP (COPY-BP FIRST-BP))
  286.      (FUNCTION-SPEC)
  287.      (DEFINITION-TYPE)
  288.      (STR)
  289.      (INT-LINE)
  290.      (first-time t)
  291.      (future-line)                ; we actually read into future line
  292.      (future-int-line)
  293.      (PREV-NODE-START-BP FIRST-BP)
  294.      (PREV-NODE-DEFINITION-LINE NIL)
  295.      (PREV-NODE-FUNCTION-SPEC NIL)
  296.      (PREV-NODE-TYPE 'HEADER)
  297.      (PREVIOUS-NODE NIL)
  298.      (NODE-LIST NIL)
  299.      (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE)))
  300.     (NIL)
  301.       ;; If we have a stream, read another line.
  302.       (when (AND STREAM (NOT EOFFLG))
  303.     (let ((lookahead (if future-line 1 *sectionize-line-lookahead*)))
  304.       (dotimes (i lookahead)        ; startup lookahead
  305.         (MULTIPLE-VALUE (future-LINE EOFFLG)
  306.           (LET ((DEFAULT-CONS-AREA *LINE-AREA*))
  307.         (SEND STREAM ':LINE-IN LINE-LEADER-SIZE)))
  308.         (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE)))
  309.         (when first-time
  310.           (setq first-time nil)
  311.           (setq line future-line)
  312.           (setq int-line future-int-line))
  313.         (when eofflg
  314.           (return)))))
  315.  
  316.       (SETQ INT-LINE LINE)
  317.  
  318.       (when int-line
  319.     (MOVE-BP BP INT-LINE 0))        ;Record as potentially start-bp for a section
  320.  
  321.       ;; See if the line is the start of a defun.
  322.       (WHEN (AND LINE
  323.          (LET (ERR)
  324.            (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE)
  325.              (SEND SELF ':SECTION-NAME INT-LINE BP STATE))
  326.            (NOT ERR)))
  327.     (PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST)
  328.     (SECTION-COMPLETION FUNCTION-SPEC STR NIL)
  329.     ;; List methods under both names for user ease.
  330.     (LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION
  331.                       FUNCTION-SPEC INT-LINE)))
  332.       (WHEN OTHER-COMPLETION
  333.         (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL)))
  334.     (LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK)))
  335.       ;; Don't make a section node if it's completely empty.  This avoids making
  336.       ;; a useless Buffer Header section node. Just set all the PREV variables
  337.       ;; so that the next definition provokes the *right thing*
  338.       (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP)
  339.         (SETQ PREVIOUS-NODE
  340.           (ADD-SECTION-NODE PREV-NODE-START-BP
  341.                     (SETQ PREV-NODE-START-BP PREV-NODE-END-BP)
  342.                     PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
  343.                     PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
  344.                     (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
  345.                           THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
  346.                                (EQ PREV-NODE-TYPE TYPE)))
  347.                     *TICK* BUFFER-TICK)
  348.                     BUFFER-TICK))
  349.         (PUSH PREVIOUS-NODE NODE-LIST)))
  350.     (SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC
  351.           PREV-NODE-TYPE DEFINITION-TYPE
  352.           PREV-NODE-DEFINITION-LINE INT-LINE))
  353.       ;; After processing the last line, exit.
  354.       (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT)))
  355.     ;; If reading a stream, we should not have inserted a CR
  356.     ;; after the eof line.
  357.     (WHEN STREAM
  358.       (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T))
  359.     ;; The rest of the buffer is part of the last node
  360.     (UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P)
  361.       ;; ---oh dear, what sort of section will this be? A non-empty HEADER
  362.       ;; ---node.  Well, ok for now.
  363.       (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP
  364.                   PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
  365.                   PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
  366.                   (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
  367.                         THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
  368.                              (EQ PREV-NODE-TYPE TYPE)))
  369.                       *TICK* BUFFER-TICK)
  370.                   BUFFER-TICK)
  371.         NODE-LIST)
  372.       (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST)))
  373.     (SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST))
  374.     (SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER)))
  375.     (SETQ ABNORMAL NIL)            ;timing windows here
  376.     ;; Speed up completion if enabled.
  377.     (WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS*
  378.       (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*))
  379.     (SETQ *ZMACS-COMPLETION-AARRAY*
  380.           (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*))
  381.     (RETURN
  382.       (VALUES 
  383.         (CL:SETF (ZMACS-SECTION-LIST BUFFER)
  384.              (NREVERSE DEFINITION-LIST))
  385.         ABNORMAL))))))
  386.  
  387.  
  388.